df <- read_rds('life_expectancy_data.RDS')
str(df)
## Classes 'data.table' and 'data.frame': 195 obs. of 23 variables:
## $ Country : chr "Afghanistan" "Albania" "Algeria" "Angola" ...
## $ Year : int 2019 2019 2019 2019 2019 2019 2019 2019 2019 2019 ...
## $ Gender : chr "Female" "Female" "Female" "Female" ...
## $ Life expectancy : num 66.4 80.2 78.1 64 78.1 ...
## $ Unemployment : num 14.06 11.32 18.63 7.84 8.26 ...
## $ Infant Mortality : num 42.9 7.7 18.6 44.5 5.1 ...
## $ GDP : num 1.88e+10 1.54e+10 1.72e+11 8.94e+10 1.69e+09 ...
## $ GNI : num 1.91e+10 1.52e+10 1.68e+11 8.19e+10 1.58e+09 ...
## $ Clean fuels and cooking technologies : num 36 80.7 99.3 49.6 100 ...
## $ Per Capita : num 494 5396 3990 2810 17377 ...
## $ Mortality caused by road traffic injury: num 15.9 11.7 20.9 26.1 0 ...
## $ Tuberculosis Incidence : num 189 16 61 351 0 29 26 2.2 6.9 6 ...
## $ DPT Immunization : num 66 99 91 57 95 ...
## $ HepB3 Immunization : num 66 99 91 53 99 ...
## $ Measles Immunization : num 64 95 80 51 93 ...
## $ Hospital beds : num 0.432 3.052 1.8 0.8 2.581 ...
## $ Basic sanitation services : num 49 99.2 86.1 51.4 85.5 ...
## $ Tuberculosis treatment : num 91 88 86 69 72.3 ...
## $ Urban population : num 25.8 61.2 73.2 66.2 24.5 ...
## $ Rural population : num 74.2 38.8 26.8 33.8 75.5 ...
## $ Non-communicable Mortality : num 36.2 6 12.8 19.4 17.6 ...
## $ Sucide Rate : num 3.6 2.7 1.8 2.3 0.8 ...
## $ continent : Factor w/ 5 levels "Africa","Americas",..: 3 4 1 1 2 2 4 2 5 4 ...
## - attr(*, ".internal.selfref")=<externalptr>
## - attr(*, "sorted")= chr "Country"
#summary(df)
Сделайте интерактивный plotly график любых двух нумерических колонок. Раскрасть по колонке континента, на котором расположена страна
plot_ly(
data = df[(df$`HepB3 Immunization` != 0) & (df$`Urban population` != 0),],
x = ~ `HepB3 Immunization` ,
y = ~ `Urban population`,
color = ~ continent,
colors = "Set2"
) |>
layout(
title = 'Соотношение городского населения и уровня иммунизации от гепатита B',
yaxis = list(title = 'Urban population',
zeroline = FALSE),
xaxis = list(title = 'HepB3 Immunization',
zeroline = FALSE))
Проведите тест, на сравнение распределений колонки
Life expectancy между группами стран Африки и Америки. Вид
статистического теста определите самостоятельно. Визуализируйте
результат через библиотеку rstatix.
df |>
get_summary_stats(`Life expectancy`, type = "mean_sd")
## # A tibble: 1 × 4
## variable n mean sd
## <fct> <dbl> <dbl> <dbl>
## 1 Life expectancy 195 75.5 7.68
df_continent <- df |>
filter(continent %in% c('Africa', 'Americas'))
#QQ-plot
ggqqplot(df_continent,
x = "Life expectancy", facet.by = "continent")
#Применение теста Шапиро-Уилка для оценки нормальности распределения
df_continent |>
group_by(continent) |>
summarize(shapiro_p = shapiro.test(`Life expectancy`)$p.value)
## shapiro_p
## 1 0.001830728
Распределение переменной Life expectancy значимо
отличается от нормального в исследуемых континентах (p<0.05). Можем
применить тест Манна-Уитни для сравнения распределений.
stat.test <- df_continent |>
wilcox_test(`Life expectancy` ~ continent) |>
add_xy_position(x = "continent")
stat.test
## # A tibble: 1 × 11
## .y. group1 group2 n1 n2 statistic p y.position groups xmin
## <chr> <chr> <chr> <int> <int> <dbl> <dbl> <dbl> <name> <dbl>
## 1 Life exp… Africa Ameri… 52 38 107 6.34e-13 86.6 <chr> 1
## # ℹ 1 more variable: xmax <dbl>
Визуализация результатов
ggboxplot(
df_continent,
x = "continent", y = "Life expectancy",
ylab = "Life expectancy", xlab = "Сontinent",
add = "jitter"
) +
labs(subtitle = get_test_label(stat.test, detailed = TRUE)) +
stat_pvalue_manual(stat.test, tip.length = 0)
Сделайте новый датафрейм, в котором оставите все численные колонки
кроме Year. Сделайте корреляционный анализ этих данных.
Постройте два любых типа графиков для визуализации корреляций.
#Создадим датафрейм с количественными переменными
df_num <- df |>
select(where(is.numeric) & !`Year`)
Корреляционный анализ
df_cor <- cor(df_num) |> round(2)
df_cor
## Life expectancy Unemployment
## Life expectancy 1.00 -0.12
## Unemployment -0.12 1.00
## Infant Mortality -0.83 0.10
## GDP 0.17 -0.11
## GNI 0.18 -0.11
## Clean fuels and cooking technologies 0.76 0.06
## Per Capita 0.60 -0.18
## Mortality caused by road traffic injury -0.65 0.17
## Tuberculosis Incidence -0.58 0.12
## DPT Immunization 0.50 -0.15
## HepB3 Immunization 0.40 -0.10
## Measles Immunization 0.53 -0.17
## Hospital beds 0.48 -0.15
## Basic sanitation services 0.85 0.03
## Tuberculosis treatment -0.32 -0.05
## Urban population 0.58 0.09
## Rural population -0.58 -0.09
## Non-communicable Mortality -0.63 0.13
## Sucide Rate 0.16 0.01
## Infant Mortality GDP GNI
## Life expectancy -0.83 0.17 0.18
## Unemployment 0.10 -0.11 -0.11
## Infant Mortality 1.00 -0.17 -0.16
## GDP -0.17 1.00 0.99
## GNI -0.16 0.99 1.00
## Clean fuels and cooking technologies -0.78 0.14 0.13
## Per Capita -0.32 0.17 0.18
## Mortality caused by road traffic injury 0.65 -0.12 -0.11
## Tuberculosis Incidence 0.56 -0.09 -0.09
## DPT Immunization -0.59 0.11 0.11
## HepB3 Immunization -0.53 0.09 0.08
## Measles Immunization -0.59 0.10 0.10
## Hospital beds -0.52 0.13 0.13
## Basic sanitation services -0.77 0.15 0.15
## Tuberculosis treatment 0.28 -0.02 -0.02
## Urban population -0.47 0.15 0.17
## Rural population 0.47 -0.15 -0.17
## Non-communicable Mortality 0.67 -0.19 -0.18
## Sucide Rate 0.06 0.11 0.13
## Clean fuels and cooking technologies
## Life expectancy 0.76
## Unemployment 0.06
## Infant Mortality -0.78
## GDP 0.14
## GNI 0.13
## Clean fuels and cooking technologies 1.00
## Per Capita 0.39
## Mortality caused by road traffic injury -0.60
## Tuberculosis Incidence -0.55
## DPT Immunization 0.45
## HepB3 Immunization 0.38
## Measles Immunization 0.50
## Hospital beds 0.44
## Basic sanitation services 0.84
## Tuberculosis treatment -0.31
## Urban population 0.59
## Rural population -0.59
## Non-communicable Mortality -0.66
## Sucide Rate 0.01
## Per Capita
## Life expectancy 0.60
## Unemployment -0.18
## Infant Mortality -0.32
## GDP 0.17
## GNI 0.18
## Clean fuels and cooking technologies 0.39
## Per Capita 1.00
## Mortality caused by road traffic injury -0.42
## Tuberculosis Incidence -0.31
## DPT Immunization 0.21
## HepB3 Immunization 0.09
## Measles Immunization 0.22
## Hospital beds 0.25
## Basic sanitation services 0.45
## Tuberculosis treatment -0.33
## Urban population 0.43
## Rural population -0.43
## Non-communicable Mortality -0.36
## Sucide Rate 0.32
## Mortality caused by road traffic injury
## Life expectancy -0.65
## Unemployment 0.17
## Infant Mortality 0.65
## GDP -0.12
## GNI -0.11
## Clean fuels and cooking technologies -0.60
## Per Capita -0.42
## Mortality caused by road traffic injury 1.00
## Tuberculosis Incidence 0.41
## DPT Immunization -0.34
## HepB3 Immunization -0.26
## Measles Immunization -0.31
## Hospital beds -0.49
## Basic sanitation services -0.63
## Tuberculosis treatment 0.31
## Urban population -0.37
## Rural population 0.37
## Non-communicable Mortality 0.41
## Sucide Rate -0.11
## Tuberculosis Incidence DPT Immunization
## Life expectancy -0.58 0.50
## Unemployment 0.12 -0.15
## Infant Mortality 0.56 -0.59
## GDP -0.09 0.11
## GNI -0.09 0.11
## Clean fuels and cooking technologies -0.55 0.45
## Per Capita -0.31 0.21
## Mortality caused by road traffic injury 0.41 -0.34
## Tuberculosis Incidence 1.00 -0.37
## DPT Immunization -0.37 1.00
## HepB3 Immunization -0.31 0.95
## Measles Immunization -0.37 0.88
## Hospital beds -0.20 0.32
## Basic sanitation services -0.56 0.46
## Tuberculosis treatment 0.24 -0.14
## Urban population -0.34 0.22
## Rural population 0.34 -0.22
## Non-communicable Mortality 0.48 -0.38
## Sucide Rate 0.10 0.06
## HepB3 Immunization Measles Immunization
## Life expectancy 0.40 0.53
## Unemployment -0.10 -0.17
## Infant Mortality -0.53 -0.59
## GDP 0.09 0.10
## GNI 0.08 0.10
## Clean fuels and cooking technologies 0.38 0.50
## Per Capita 0.09 0.22
## Mortality caused by road traffic injury -0.26 -0.31
## Tuberculosis Incidence -0.31 -0.37
## DPT Immunization 0.95 0.88
## HepB3 Immunization 1.00 0.86
## Measles Immunization 0.86 1.00
## Hospital beds 0.27 0.34
## Basic sanitation services 0.38 0.51
## Tuberculosis treatment -0.09 -0.14
## Urban population 0.14 0.25
## Rural population -0.14 -0.25
## Non-communicable Mortality -0.31 -0.39
## Sucide Rate -0.02 0.03
## Hospital beds Basic sanitation services
## Life expectancy 0.48 0.85
## Unemployment -0.15 0.03
## Infant Mortality -0.52 -0.77
## GDP 0.13 0.15
## GNI 0.13 0.15
## Clean fuels and cooking technologies 0.44 0.84
## Per Capita 0.25 0.45
## Mortality caused by road traffic injury -0.49 -0.63
## Tuberculosis Incidence -0.20 -0.56
## DPT Immunization 0.32 0.46
## HepB3 Immunization 0.27 0.38
## Measles Immunization 0.34 0.51
## Hospital beds 1.00 0.47
## Basic sanitation services 0.47 1.00
## Tuberculosis treatment -0.19 -0.30
## Urban population 0.27 0.55
## Rural population -0.27 -0.55
## Non-communicable Mortality -0.36 -0.52
## Sucide Rate 0.27 0.16
## Tuberculosis treatment Urban population
## Life expectancy -0.32 0.58
## Unemployment -0.05 0.09
## Infant Mortality 0.28 -0.47
## GDP -0.02 0.15
## GNI -0.02 0.17
## Clean fuels and cooking technologies -0.31 0.59
## Per Capita -0.33 0.43
## Mortality caused by road traffic injury 0.31 -0.37
## Tuberculosis Incidence 0.24 -0.34
## DPT Immunization -0.14 0.22
## HepB3 Immunization -0.09 0.14
## Measles Immunization -0.14 0.25
## Hospital beds -0.19 0.27
## Basic sanitation services -0.30 0.55
## Tuberculosis treatment 1.00 -0.28
## Urban population -0.28 1.00
## Rural population 0.28 -1.00
## Non-communicable Mortality 0.27 -0.53
## Sucide Rate -0.07 0.09
## Rural population
## Life expectancy -0.58
## Unemployment -0.09
## Infant Mortality 0.47
## GDP -0.15
## GNI -0.17
## Clean fuels and cooking technologies -0.59
## Per Capita -0.43
## Mortality caused by road traffic injury 0.37
## Tuberculosis Incidence 0.34
## DPT Immunization -0.22
## HepB3 Immunization -0.14
## Measles Immunization -0.25
## Hospital beds -0.27
## Basic sanitation services -0.55
## Tuberculosis treatment 0.28
## Urban population -1.00
## Rural population 1.00
## Non-communicable Mortality 0.53
## Sucide Rate -0.09
## Non-communicable Mortality Sucide Rate
## Life expectancy -0.63 0.16
## Unemployment 0.13 0.01
## Infant Mortality 0.67 0.06
## GDP -0.19 0.11
## GNI -0.18 0.13
## Clean fuels and cooking technologies -0.66 0.01
## Per Capita -0.36 0.32
## Mortality caused by road traffic injury 0.41 -0.11
## Tuberculosis Incidence 0.48 0.10
## DPT Immunization -0.38 0.06
## HepB3 Immunization -0.31 -0.02
## Measles Immunization -0.39 0.03
## Hospital beds -0.36 0.27
## Basic sanitation services -0.52 0.16
## Tuberculosis treatment 0.27 -0.07
## Urban population -0.53 0.09
## Rural population 0.53 -0.09
## Non-communicable Mortality 1.00 0.18
## Sucide Rate 0.18 1.00
Визуализация с помощью corrplot:
corrplot(df_cor, method = 'number')
С помощью функции ggpairs из пакета
GGally:
ggpairs(df_num,
title = 'Correlations in dataset',progress = F) +
theme_minimal() +
theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
Постройте иерархическую кластеризацию на датафрейме(все численные колонки кроме Year)
df_num_scaled <- scale(df_num)
df_num_dist <- dist(df_num_scaled,
method = "euclidean"
)
# Дендрограмма кластеров
df_num_hc <- hclust(d = df_num_dist,
method = "ward.D2")
# Визуализация
fviz_dend(df_num_hc,
k = 5,
k_colors = c("#191970", "#008080", "#FFD700","#800080", "#8B0000"),
cex = 0.1,
rect = TRUE)
Сделайте одновременный график heatmap и иерархической кластеризации.
pheatmap(df_num_scaled,
clustering_method = "ward.D2",
cutree_rows = 5,
cutree_cols = length(colnames(df_num_scaled)),
angle_col = 90,
main = "Dendrograms for clustering rows and columns with heatmap")
При проведении кластерного анализа выделим 5 кластеров. Обращает
внимание один небольшой кластер, который характеризуется переменными GDP
и GNI с сильной корреляцией.
В другом кластере связаны столбцы,характеризующие иммунизацию
населения. В отдельной группе связаны переменные Urban population, Clean
fuels and cooking technologies, Life expectancy, Basic sanitation
services.
В другом кластере связаны переменные Unemployment, Tuberculosis
treatment, Rural population, Tuberculosis Incidence, показатели
смертности
Проведите PCA анализ на этих данных. Постройте biplot график для PCA.
Раскрасьте его по значениям континентов. Переведите его в
plotly. Дайте содержательную интерпретацию PCA анализу.
df_num_scaled_pca <- prcomp(df_num_scaled)
summary(df_num_scaled_pca)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.7526 1.4841 1.3952 1.17177 1.08375 0.96347 0.9288
## Proportion of Variance 0.3988 0.1159 0.1025 0.07227 0.06182 0.04886 0.0454
## Cumulative Proportion 0.3988 0.5147 0.6172 0.68945 0.75126 0.80012 0.8455
## PC8 PC9 PC10 PC11 PC12 PC13 PC14
## Standard deviation 0.85740 0.69263 0.68937 0.59106 0.54986 0.47085 0.36596
## Proportion of Variance 0.03869 0.02525 0.02501 0.01839 0.01591 0.01167 0.00705
## Cumulative Proportion 0.88421 0.90946 0.93447 0.95286 0.96877 0.98044 0.98749
## PC15 PC16 PC17 PC18 PC19
## Standard deviation 0.34546 0.26941 0.20224 0.06968 1.012e-15
## Proportion of Variance 0.00628 0.00382 0.00215 0.00026 0.000e+00
## Cumulative Proportion 0.99377 0.99759 0.99974 1.00000 1.000e+00
Первые 5 главных компонент объясняют 75% вариации данных. Отметка в 91% достигается только на PC9.
fviz_eig(df_num_scaled_pca, addlabels = T)
Первые две компоненты объясняют 51% дисперсии. Посмотрим, как переменные связаны с PC1 и PC2
fviz_pca_var(df_num_scaled_pca,
col.var = "contrib",
repel = TRUE # убрать наслаивание меток переменных
)
Выведем самые важные переменные (для PC1 и PC2)
fviz_pca_var(df_num_scaled_pca,
select.var = list(contrib = 10), # число переменных
col.var = "contrib",
repel = TRUE # убрать наслаивание меток переменных
)
Видим группы переменных среди наиболее важных:
показатели смертности: Infant Mortality, Non-communicable Mortality
Life expectancy, Basic sanitation services, Clean fuels and cooking technologie, Urban population
показатели иммунизации населения: Measles Immunization, DPT Immunization, HepB3 Immunization
Из графика видно, что противоположное направление имеют: Urban population и Rural population, а также показатели Life expectancy и Mortality
fviz_contrib(df_num_scaled_pca, choice = "var", axes = 1)
В первую компоненту вносят вклад большое количество переменных
fviz_contrib(df_num_scaled_pca, choice = "var", axes = 2)
Для второй компоненты значимый вклад вносят в первую очередь показатели иммунизации
fviz_contrib(df_num_scaled_pca, choice = "var", axes = 3)
Третья компонента характеризуется хорошо показателями GDP и GNI
#biplot график для PCA
df_num_scaled_biplot <- ggbiplot(df_num_scaled_pca,
repel = TRUE,
groups = as.factor(df$continent))
df_num_scaled_biplot
plotly::ggplotly(df_num_scaled_biplot)
Достаточно хорошо на графике различимы страны Европы и Америки, для которых характерны большая продолжительность жизни, высокий процент городского населения, уровень иммунизации и в противоположной стороне страны Африки, характеризующиеся преимущественно сельским населением, повышенной смертностью от разных причин
Сравните результаты отображения точек между алгоритмами PCA и UMAP.
#из лекции
umap_prep <- recipe(~., data = df_num) |>
step_normalize(all_predictors()) |>
step_umap(all_predictors()) |>
prep() |>
juice()
umap_prep |>
ggplot(aes(UMAP1, UMAP2)) +
geom_point(aes(color = as.character(df$continent))) +
labs(color = NULL)
При сравнении алгоритмов получаем схожие результаты: в одну группу попадают преимущественно страны Африки, в другую - Страны Европы и Америки. В UMAP точки ближе друг к другу, лучше визуализируются 2 кластера.
Удалите 5 случайных колонок. Проведите PCA анализ. Повторите результат 3 раза. Наблюдаете ли вы изменения в куммулятивном проценте объяснённой вариации? В итоговом представлении данных на биплотах? С чем связаны изменения между тремя PCA?
set.seed(111)
df_num_scaled <- as.data.frame(df_num_scaled)
df_num_scaled1 <- df_num_scaled |>
select(-sample(names(df_num_scaled), 5))
df_num_scaled_pca1 <- prcomp(df_num_scaled1)
summary(df_num_scaled_pca1)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.3409 1.3241 1.1930 1.05866 0.98243 0.89639 0.85050
## Proportion of Variance 0.3914 0.1252 0.1017 0.08005 0.06894 0.05739 0.05167
## Cumulative Proportion 0.3914 0.5167 0.6183 0.69836 0.76730 0.82470 0.87637
## PC8 PC9 PC10 PC11 PC12 PC13
## Standard deviation 0.69834 0.68612 0.56897 0.48609 0.41389 0.20280
## Proportion of Variance 0.03483 0.03363 0.02312 0.01688 0.01224 0.00294
## Cumulative Proportion 0.91120 0.94483 0.96795 0.98483 0.99706 1.00000
## PC14
## Standard deviation 2.454e-16
## Proportion of Variance 0.000e+00
## Cumulative Proportion 1.000e+00
fviz_eig(df_num_scaled_pca1, addlabels = T)
fviz_pca_var(df_num_scaled_pca1,
col.var = "contrib",
repel = TRUE # убрать наслаивание меток переменных
)
set.seed(222)
df_num_scaled2 <- df_num_scaled |>
select(-sample(names(df_num_scaled), 5))
df_num_scaled_pca2 <- prcomp(df_num_scaled2)
summary(df_num_scaled_pca2)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.3936 1.4007 1.2249 1.0973 0.98939 0.89446 0.71756
## Proportion of Variance 0.4092 0.1401 0.1072 0.0860 0.06992 0.05715 0.03678
## Cumulative Proportion 0.4092 0.5494 0.6566 0.7426 0.81248 0.86963 0.90641
## PC8 PC9 PC10 PC11 PC12 PC13 PC14
## Standard deviation 0.62212 0.59925 0.47278 0.38590 0.33450 0.27368 0.07027
## Proportion of Variance 0.02765 0.02565 0.01597 0.01064 0.00799 0.00535 0.00035
## Cumulative Proportion 0.93405 0.95970 0.97567 0.98630 0.99430 0.99965 1.00000
fviz_eig(df_num_scaled_pca2, addlabels = T)
fviz_pca_var(df_num_scaled_pca2,
col.var = "contrib",
repel = TRUE # убрать наслаивание меток переменных
)
set.seed(333)
df_num_scaled3 <- df_num_scaled |>
select(-sample(names(df_num_scaled), 5))
df_num_scaled_pca3 <- prcomp(df_num_scaled3)
summary(df_num_scaled_pca3)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.4009 1.3898 1.2955 1.11213 0.96916 0.90270 0.72369
## Proportion of Variance 0.4118 0.1380 0.1199 0.08835 0.06709 0.05821 0.03741
## Cumulative Proportion 0.4118 0.5497 0.6696 0.75793 0.82502 0.88322 0.92063
## PC8 PC9 PC10 PC11 PC12 PC13 PC14
## Standard deviation 0.65628 0.53057 0.4821 0.34509 0.20610 0.07007 2.857e-16
## Proportion of Variance 0.03076 0.02011 0.0166 0.00851 0.00303 0.00035 0.000e+00
## Cumulative Proportion 0.95140 0.97151 0.9881 0.99662 0.99965 1.00000 1.000e+00
fviz_eig(df_num_scaled_pca3, addlabels = T)
fviz_pca_var(df_num_scaled_pca3,
col.var = "contrib",
repel = TRUE # убрать наслаивание меток переменных
)
ggplotly(ggbiplot(df_num_scaled_pca1,
repel = TRUE,
groups = as.factor(df$continent)) )
ggplotly(ggbiplot(df_num_scaled_pca2,
repel = TRUE,
groups = as.factor(df$continent)) )
ggplotly(ggbiplot(df_num_scaled_pca3,
repel = TRUE,
groups = as.factor(df$continent)) )
Во всех случаях кумулятивный процент объясненной вариации первых двух компонент более 50%. В зависимости от того какие колонки были удалены, мы получаем разный вклад переменных в компоненты. Полученные биплоты достаточно сильно отличаются друг от друга.